PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/coun.com/COUN.PAS

Pascal/Delphi Source File | 1990-06-12 | 13.4 KB | 357 lines

UNIT COUN;

{  Sorry about the name but, what else do you call a COmpress/UNCompress
   routine.

   Anyway, this routine was created to compress a PASCAL RECORD which has
   STRING variables.  To do this I mearly pack the rest of the data in behind
   the used portion of a TPas String.  Example:

          CUSTREC = RECORD
            LNAME : STRING[40];
            FNAME : STRING[40];

         CUSTREC.FNAME := 'CARL';
         CUSTREC.LNAME := 'FRANZ';

   The record CUSTREC takes up 82 bytes.  When this routine is done with it
   it takes up 11 bytes. '$CARL$FRANZ' where $ is the length Byte of the
   string (04H and 05H respectively).

   The routines COMRESS and UNCOMPRESS accepts a map of the RECORD, the RECORD,
   and a BYTE ARRAY large enough to accept the RECORD.

   COMPRESS will return the length of the compressed record as an integer.

   NOTE: DO NOT attempt to compress/decompress in place ie. use the same
         variable for both INDATA and OUTDATA.  COMPRESS will probably work
         but DECOMPRESS absolutely will NOT work.                             }

INTERFACE

VAR
   COUNERR : BYTE;
   COUNWHR : BYTE;

FUNCTION Compress(Cmap : STRING; VAR InData; VAR OutData) : INTEGER;
{     where:  Cmap - a string variable containing the map of the record
              InData  - your record
              OutData - a buffer where the compresses record is returned

     Returns - an integer whis is the length of the compressed record        }

PROCEDURE UnCompress(Cmap : STRING; VAR InData; VAR OutData);
{     where:  Cmap - a string variable containing the map of the record
              InData  - your compressed record
              OutData - whereever you what the uncompressed record returned  }


IMPLEMENTATION

TYPE
     BA = ARRAY [1..32000] OF BYTE; {array type for bopping thru the data}

     L1 = RECORD        { rec for parsing tokens from record map }
        Ctype : CHAR;   {the type of data to be moved}
        Size : INTEGER; {the size of the data to be moved, or array size,
                         or if ']' the position of the matching '[' }
        Decr : INTEGER  {This is used as a down counter for iterating an array }
     END;

     L2 = RECORD        { RECORD necesssary when parsing multi-level arrays }
        Rtn : BYTE;     {the L1 index to return to on finding the matching '['}
     END;

   lp1 = ARRAY [1..100] OF l1;  {parsing ARRAY OF TYPE L1 }
   lp2 = ARRAY [1..100] OF l2;  {nested array stack}

CONST numset : SET OF CHAR = ['0'..'9'];   {is this token a number ?}

VAR
   lpa1     : ^lp1;    {declaration of a pointer to the parsing ARRAY}
   lpa2     : ^lp2;    {declaration of a pointer to the ARRAY parsing stack }
   done,               {next after last element in LPA1 when parsing is done }
   Lpa1Indx,           {index for LPA1}
   Lpa2Indx : BYTE;    {index for LPA2}
   OutPtr   : ^BA;     {pointer to the output byte array}
   InPtr    : ^BA;     {pointer to your RECORD, redefines as a byte array}
   OutIndx,            {index to the output ARRAY }
   InIndx   : INTEGER; {index to your record when viewed as a BYTE ARRAY}


{  This PROCEDURE parses the RECORD Map into something useful, namely an
   ARRAY OF directions to how to Compress or UnCompress your RECORD.  If
   this sounds simple just try to process this in your head '[25[25[25s]]]'.
   If you can do it then you should be writing compilers.                   }

PROCEDURE ParseCMap(CMap: STRING);
VAR
   BracketCnt,
   CIndx : BYTE;
   Lp1t  : l1;
   Lp2t  : l2;
   token : CHAR;

FUNCTION GetNum : INTEGER;
{  GetNum parses the CMap for numbers, it turns a stringed number into an
   Integer number.  I could have used VAL but VAL is such a cluge}
VAR
    SSize : INTEGER; {String size - intermediate hold when evaluating the nums}
    NToken : char;   {The character currently being evaluated from CMap }
BEGIN
    SSize := 0;
    NToken := CMap[SUCC(CIndx)];
    IF NOT (NToken IN NumSet) THEN
       SSize := 255
    ELSE
       WHILE (NToken IN NumSet) DO
          BEGIN
          SSize := SSize * 10 + (ORD(NToken) - ORD('0'));
          INC(CIndx);
          NToken := CMap[SUCC(CIndx)];
          END;
    GetNum := SSize;
END;


FUNCTION GetToken : boolean;
{  GetToken gets a token from the CMap and makes some decisions about it, like
   is this a STRING, should I try to find a number associated with it, etc.
   It then loads a L1 type record with pertinent information about the token. }
BEGIN
    IF cindx > ord(CMap[0]) THEN  {we are at the end of the record map}
       BEGIN
            IF NOT (bracketCnt = 0) THEN   {mismatched brackets?}
               COUNERR := 3;
            GetToken := FALSE;
            exit;
       END;
    token := UpCase(CMap[cindx]);    {get a character from the record map}
    lp1t.Decr := 0;
    lp1t.Ctype := token;
    CASE token OF
    'S'      : BEGIN  {Is this a STRING?}
                 lp1t.size := GetNum;
               END;
    '['      : BEGIN  {Is this the start of an array?}
                 lp1t.size := GetNum;
                 INC(BracketCnt);
               END;
    ']'      : BEGIN  {Is this the END OF an ARRAY definition }
                 lp1t.size := 0;
                 DEC(BracketCnt);
               END;
    'W', 'I' : BEGIN  {Is this a Word or INTEGER}
                 lp1t.size := sizeof(word);
               END;
    'L', 'P' : BEGIN  {is this a LONGINT or POINTER}
                 lp1t.size := sizeof(pointer);
               END;
    'C', 'B' : BEGIN  {Is this a CHAR or BYTE}
                 lp1t.size := sizeof(BYTE);
               END;
    'R'      : BEGIN  {is this a real number?}
                 lp1t.size := sizeof(Real);
               END;
    ','      : BEGIN  {is this a comma?}
                 lp1t.size := 0;
               END;
    ELSE BEGIN
             IF (token in numset) THEN {Is it a data length?}
                 BEGIN
                   lp1t.Ctype := ' ';
                   DEC(CIndx);
                   Lp1T.size := GetNum;
                 END
             ELSE
                BEGIN
                   COUNERR := 2;
                   COUNWHR := CIndx;
                END;
         END;
    END;
    INC(CIndx);
    GetToken := True;
END;

{  The ParseCMap mainline loads the parsing arrays }

BEGIN
   Lpa1Indx := 1; Lpa2Indx := 1; CIndx := 1; BracketCnt:= 0;
   WHILE (GetToken) DO
   BEGIN
       IF (lp1t.Ctype = '[') THEN {if start of array load l2 with return #}
            BEGIN
              lp2t.rtn := Lpa1Indx;
              lpa2^[Lpa2Indx] := lp2t;
              INC(Lpa2Indx);
            END;
       IF (lp1t.Ctype = ']') THEN {if end of array get return # from l2}
            BEGIN
              DEC(lpa2indx);
              lp1t.size := lpa2^[lpa2indx].rtn;
            END;
       if lp1t.ctype <> ',' then  {if not a comma load parse array with data}
       begin
           lpa1^[Lpa1Indx] := lp1t;
           INC(Lpa1Indx);
       end;
   END;
   done := lpa1Indx;
END;



{  The rest of this mess is the actual Compress/UnCompress logic.  It runs
   thru the Token Array and compresses strings, moves other types, and
   processes the arrays within your record.                                   }

PROCEDURE CompressAny(size : BYTE);
{  This routine moves any non STRING data to the output BYTE ARRAY  }
BEGIN
  MOVE(InPtr^[InIndx], OutPtr^[OutIndx],Size);
  InIndx := InIndx + Size;
  OutIndx := OutIndx + Size;
END;

PROCEDURE CompressStr(size : BYTE);
{  This routine moves any STRING data to the output BYTE ARRAY  }
VAR
   SLen : BYTE;
BEGIN
    SLen := InPtr^[InIndx];     {string length is first byte of string}
    INC(SLen);                  {incremint past the length}
    MOVE(InPtr^[InIndx], OutPtr^[OutIndx], SLen);   {move the string}
    InIndx := InIndx + Size + 1; {set InIndx past the allocated length}
    OutIndx := OutIndx + SLen; {set the outindex past the actual data length}
END;

PROCEDURE UnCompressAny(size : BYTE);
{  This routine moves any non STRING data to the output byte array - UnCompress}
BEGIN
   MOVE(InPtr^[InIndx], OutPtr^[OutIndx],Size);  {move the data}
   InIndx := InIndx + Size;     {increment both the InIndx and OutIndx  }
   OutIndx := OutIndx + Size;
END;

PROCEDURE UnCompressStr(size : INTEGER);
{  This routine moves any STRING data to the output byte array - UnCompress}
VAR
   SLen : INTEGER;
   SStart : INTEGER;
BEGIN
   SLen := InPtr^[InIndx] + 1;     {get the string length from the byte array}
   MOVE(InPtr^[InIndx], OutPtr^[OutIndx], SLen);   {move the string}
   OutIndx := OutIndx + Size + 1;   {inc the InIndx and OutIndx past this data}
   InIndx := InIndx + Slen;
END;

{  This is the parse table processor for both the compress and uncompress.
   It steps thru the Parsed token array a step at a time and makes decisions
   about what to do.  There are 4 decisions to make: 1) If this is a STRING
   then process it; 2) IF this is some other variable type then move it;
   3) IF this is a Start-Array type, then set up the counter; 4) If this is a
   End-Array type then either decrament the counter, or if counter is 0 then
   go on to the rest of the data.                                             }

PROCEDURE ProcessTbl(cd : CHAR);

BEGIN
   lpa1indx := 1;
   REPEAT
       CASE lpa1^[Lpa1Indx].CType OF
       '[' : BEGIN   {if array start move array count to decr}
                lpa1^[lpa1indx].Decr := pred(lpa1^[Lpa1Indx].size);
             END;
       ']' : BEGIN   {if end of array either dec the Decr or if 0 go on }
                IF (lpa1^[lpa1^[lpa1indx].size].Decr > 0) THEN
                BEGIN
                    lpa1indx := lpa1^[lpa1indx].size; {reset index to matching
                                                       start-array element}
                    DEC(lpa1^[lpa1indx].Decr);        {subtract 1 from decr}
                END;
             END;
       'S' : BEGIN   {either compress or uncompress a string}
                IF (cd = 'C') THEN
                   CompressStr(lpa1^[Lpa1Indx].size)
                ELSE
                   UnCompressStr(lpa1^[Lpa1Indx].size);
             END;
       ELSE  IF (cd = 'C') THEN {either compress or uncompress other type}
                CompressAny(lpa1^[Lpa1Indx].size)
             ELSE
                UnCompressAny(lpa1^[Lpa1Indx].size);
       END;
       INC(Lpa1Indx);
   UNTIL (lpa1indx = done);
END;

{$F+} FUNCTION HEAPFUNC(Size:Word) : INTEGER; {$F-}
{ Boy is Turbo Pascal stupid sometimes, ya know.
  This is just to keep the New from blowing up on not enough memory
     should the occasion ever arise                                 }
BEGIN
   HeapFunc := 1; {return null pointer instead of abending on error}
END;

PROCEDURE UnCompress(CMap : STRING;VAR InData;VAR OutData);
{ UnCompress gets addressability to your compressed data and output RECORD,
  gets memory for the parse arrays, calls ParseCMap, uncompresses the data }
VAR
   BAI     : BA absolute InData;    {your compressed record}
   BAO     : BA absolute OutData;   {your uncompressed record}
   Hptr    : Pointer;

BEGIN
     Hptr := HeapError;                {see page 200 of the 5.0 Tpas manual }
     HeapError := @HeapFunc;
     COUNERR := 0; COUNWHR := 0;        {zero the error codes}
     InPtr := @BAI; OutPtr := @BAO;     {Turn you data into byte arrays}
     InIndx := 1; OutIndx := 1;         {set indexes to 1}
     New(lpa1); New(lpa2);              {allocate space for parsing arrays }
     IF (lpa1 = nil) or (lpa2 = nil) THEN {check for mem allocation errors }
         BEGIN
            COUNERR := 1;
            IF (lpa1 <> nil) THEN Dispose(lpa1);
         END
     ELSE BEGIN
        parseCMap(CMap);                 {parse the Cmap input into lpa1}
        if COUNERR  = 0 then             {if no errors in parseing}
            ProcessTbl('D');             {decompress the record}
        Dispose(lpa1); Dispose(lpa2);    {dispose of the parse arrays }
     END;
     HeapError := HPtr; {reset the heap error whatever (p200 tpas5.0 manual)}
END;

FUNCTION Compress(CMap : STRING;VAR InData;VAR OutData) : INTEGER;
{ Compress gets addressability to your RECORD and output ARRAY as BYTE arrays,
  gets memory FOR the parse arrays, calls ParseCMap, decompresses the data }
VAR
   BAI     : BA absolute InData;     {your record as a byte array}
   BAO     : BA absolute OutData;    {your record compresses as a byte array}
   Hptr    : Pointer;                {never mind}

BEGIN
     Hptr := HeapError;              {see page 200 of the 5.0 Tpas manual}
     HeapError := @HeapFunc;
     COUNERR := 0; COUNWHR := 0;     {zero the error codes}
     InPtr := @BAI; OutPtr := @BAO;  {turn you data into byte arrays}
     InIndx := 1; OutIndx := 1;      {reset the indexes}
     New(lpa1); New(lpa2);           {allocate space for the parse arrays}
     IF (lpa1 = nil) or (lpa2 = nil) THEN {if allocation error}
         BEGIN
            COUNERR := 1;
            IF (lpa1 <> nil) THEN Dispose(lpa1);
         END
     ELSE BEGIN
        parseCMap(CMap);              {parse the record map}
        if COUNERR  = 0 then          {if no parse errors}
            ProcessTbl('C');          {compress your record}
        Dispose(lpa1); Dispose(lpa2); {dispose of the parsing arrays}
        Compress := pred(OutIndx);    {return the size of compressed record}
     END;
     HeapError := HPtr;               {reset the heap error process pointer}
END;

END.